COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 This program is henceforth called: ``SAIL constraint combinatorial pairing
C00011 ENDMK
C⊗;
;;; This program is henceforth called: ``SAIL constraint combinatorial pairing
;;; program'' or SCCPP.

;;;First, in SCCPP there are functions with 7 arguments. For example,
;;;the first function starts out:
;;;
;;;(DEFUN PAIRS 
;;;       (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;;	  NIL-PAIRS) ...)
;;;
;;;I suggest the following translation:
;;;
;;;(DEFUN PAIRS n
;;;       ((LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
;;;		  NIL-PAIRS) ...)
;;;	(ARG 1)(ARG 2)(ARG 3)(ARG 4)(ARG 5)(ARG 6)(ARG 7)))
;;;
;;;(*list a1 ... an) => (cons a1 (cons a2 ...(cons an-1 an)))
;;;
;;;(*catch x y) evaluates the form y. x should EVAL to a tag. If y returns
;;;normally, the value of the *catch is the value of y. If the evaluation
;;;of y entails the evaluation of a form like (*throw q v) where q EVALs
;;;to the same tag that x did, then v is evaluated and the value of the *catch
;;;is the value of v. Unless, there is an intervening *catch with the same
;;;tag...
;;;
;;;MAPCAN is MAPCAR with NCONC instead of CONS.
;;;
;;;1+, +, < etc are FIXNUM versions of ADD1, PLUS, LESSP etc.
;;;
;;;(FUNCALL fun x1 ... xn) evaluates all of its arguments and
;;;applies the value of fun to the arguments x1 ... xn. So
;;;(FOO a b c d) = (FUNCALL 'FOO a b c d)
;;;
;;;			-rpg-


(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
	      NIL-PAIRS) 
       ((LAMBDA (XXX) 
	 (MAPCAN 
	  (FUNCTION(LAMBDA (I) 
	      (PROGN
	       (COND
		(MUST-APPEAR
		 (*CATCH
		  'OUT
		  (PROGN
		   (MAPC 
		    (FUNCTION(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
					 (*THROW 'OUT T)))))
		    I)
		   NIL)))
		(T)))
	      (LIST I)))
	  XXX)) 
	(MAPCAR (FUNCTION(LAMBDA (I) (CDR I)))
		(COND ((< (LENGTH X)
			  (+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
		       (PAIRS1 (MAKE-POSSIBILITY-1 X
						   Y
						   FUN
						   APPLY-CONSTRAINTS
						   CONSTRAINTS
						   NIL-PAIRS)))
		      (T (PAIRS2 (MAKE-POSSIBILITY-2 Y
						     X
						     FUN
						     APPLY-CONSTRAINTS
						     CONSTRAINTS
						     NIL-PAIRS)))))))


(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I)))))
			     Q))
	    (Q)))
	  (MAPCAN 
	   (FUNCTION(LAMBDA (I) 
	      (PROGN
	       (SETQ N 0)
	       ((LAMBDA (A) (AND A
				 (OR (NULL CONSTRAINTS)
				     (NULL APPLY-CONSTRAINTS)
				     (FUNCALL APPLY-CONSTRAINTS
					      CONSTRAINTS))
				 (LIST (LIST* I A))))
		(MAPCAN 
		 (FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN I J))
					      (LIST* N J)))))))
		 Y)))))
	   X)))
	0))


(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC (FUNCTION(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I)))))
			     Q))
	    (Q)))
	  (MAPCAN 
	   (FUNCTION(LAMBDA (I) 
	      (PROGN
	       (SETQ N 0)
	       ((LAMBDA (A) (AND A
				 (OR (NULL CONSTRAINTS)
				     (NULL APPLY-CONSTRAINTS)
				     (FUNCALL APPLY-CONSTRAINTS
					      CONSTRAINTS))
				 (LIST (LIST* I A))))
		(MAPCAN 
		 (FUNCTION(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN J I))
					      (LIST* N J)))))))
		 Y)))))
	   X)))
	0))


(DEFUN PAIRS1 (L) 
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    (FUNCTION(LAMBDA (PAIRS) 
	       (PROGN
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   (FUNCTION(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (PROGN (COND ((CAR (MEMBER (CAR I)
							 AVOID))
					    (LIST* AVOID ANS))
					   (T (LIST* (LIST* (CAR I)
							    AVOID)
						     (LIST* CAND
							    (CDR I))
						     ANS)))))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS)))))
	    (PAIRS1 (CDR L))))
	  (CAAR L)
	  (CDAR L)))))


(DEFUN PAIRS2 (L) 
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    (FUNCTION(LAMBDA (PAIRS) 
	       (PROGN
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   (FUNCTION(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (PROGN (COND ((CAR (MEMBER (CAR I)
							 AVOID))
					    (LIST* AVOID ANS))
					   (T (LIST* (LIST* (CAR I)
							    AVOID)
						     (LIST* (CDR I)
							    CAND)
						     ANS)))))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS))))) 
	    (PAIRS2 (CDR L))))
	  (CAAR L)
	  (CDAR L)))))

(declare (special a b))
(setq a '(
	  (1 2)
	  (7 8)
	  (9 0)
	  (a b c)
	  (a b c)
	  (d e f)
	  (d e f)
	  (g h i)
	  (g h i)
	  (j k l)
	  (m n o)
	  (p q r)
	  ))
(setq b '(
	  (a b c)
	  (j k l)
	  (d e f)
	  (p q r)
	  (g h i)
	  (9 0)
	  (a b c)
	  (p q r)
	  (7 8)
	  (j k l)
	  (2 1)
	  (3 2)
	  (8 7)
	  (9 8)
	  (0 9)
	  (m n o)
	  (d e f)
	  (j k l)
	  (m n o)
	  (d e f)
	  (p q r)
	  (g h i)
	  ))

(defun test ()
 ((lambda (t1 x gt)
	  (setq x (pairs a b () 'equal () () ()))
	  (setq t1 (- (runtime) t1))
	  (setq gt (- (status gctime) gt))
	  (print (length x))
	  (print (list 'runtime
		       (QUOTIENT (FLOAT  (- t1 gt))
				 1000000.)))
	  (print (list 'gctime
		       (quotient (float gt) 1000000.))))
  (runtime) ()(status gctime)))